home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Yerk 3.64
/
Float source
/
Float
< prev
next >
Wrap
Text File
|
1992-06-24
|
6KB
|
197 lines
\ float -- floating-point classes: Float and fArray
\ 9/22/85 cbd Version 1.0
\ 8/16/86 cdn Added LocalFloat
\ 4/10/90 rfl fixed fltAt and fltTo to check for ivars
\ 9/25/90 rfl added +to:
\ 3/15/92 rfl added put: farray get: farray
\ 6/24/92 rfl protect stack from getting more floats that floatmem allows
decimal
\ ========= Code support for methods - CBD 9/85 ======
:CODE getFlt
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get new float in d1
move.l d5,a2 ; get mstack
move.l (a2),a0 ; base address
adda.l a3,a0
lea 2(a3,d1.l),a1
move.l (a0)+,(a1)+ ; copy float data
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
move.l d1,-(a7) ; return new float
;CODE
:CODE putFlt
move.l (a7),d0
move.l YERK[(fltDisp)],d7
jsr 0(a3,d7.l) ; get rid of float in D0
move.l d5,a2 ; get mstack
move.l (a2),a1 ; base address
adda.l a3,a1
move.l (a7)+,d0
lea 2(a3,d0.l),a0
move.l (a0)+,(a1)+ ; copy float data
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
;CODE
\ set up stack for float object arithmetics so that the
\ result is stored in the receiver. ( parm -- rcvr parm )
:CODE fltOp
move.l d5,a2 ; get mstack
move.l (a7),d0
move.l (a2),(a7) ; base address
subq.l #2,(a7) ; floats have status word
move.l d0,-(a7)
;CODE
:CLASS Float <Super Object
10 Bytes data
\ ( -- x ) push private data onto stack
:M GET: getFlt ;M
\ ( x -- ) store float into private data
:M PUT: putFlt ;M
\ ( Float -- ) assign this float's data to another object
:M =: getFlt swap put: Float ;M
\ ----- Arithmetic operations take a stack float (not a float obj)
\ ( x -- ) add a float to the contents of this object
:M +: fltOp f+ drop ;M
\ ( x -- )
:M -: fltOp f- drop ;M
\ ( x -- )
:M *: fltOp f* drop ;M
\ ( x -- )
:M /: fltOp f/ drop ;M
\ ( -- sin ) return sine of object
:M SIN: getFlt sin ;M
\ ( -- cos ) return cosine of object
:M COS: getFlt cos ;M
\ ( -- tan ) return tangent of object
:M TAN: getFlt tan ;M
\ ( -- arcTan) return arctangent of object
:M ARCTAN: getFlt arcTan ;M
\ ( -- ln) return natural log of object
:M LN: getFlt ln ;M
\ ( -- exp ) return exp of object
:M EXP: getFlt exp ;M
\ ( -- log) return log base 10 of object
:M LOG: getFlt log ;M
\ ( -- alog) return antilog of object
:M ANTILOG: getFlt antilog ;M
\ ( -- ) convert radians to degrees and return result
:M DEG: getFlt rad2deg ;M
\ ( -- ) convert from radians to degrees and return result
:M RAD: getFlt deg2rad ;M
\ ( -- ) compute absolute value and return result
:M ABSVAL: getFlt fabs ;M
\ ( -- ) change sign and return result
:M NEG: getFlt fnegate ;M
\ ( -- ) negate this object's data
:M NEGATE: copym 2- fnegate drop ;M
\ ( -- )
:M PRINT: getFlt e. ;M
;CLASS
\ optimized access primitives for float array
:CODE fltAt
move.l YERK[(fltNew)],d7
jsr 0(a3,d7.l) ; get new float in d1
move.l d5,a2 ; get mstack
move.l (a2),a0 ; object base
adda.l a3,a0
move.l -4(a0),d7 ; get class
adda.w $12(a3,d7.l),a0 ; offset for ivar
move.l (a7),d0 ; get idx
mulu #10,d0 ; convert to offset
lea 4(a0,d0.l),a0 ; pt to element
lea 2(a3,d1.l),a1 ; pt to target
move.l (a0)+,(a1)+ ; deep copy of float data
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
move.l d1,(a7) ; push float ptr
;CODE
:CODE fltTo
move.l 4(a7),d0 ; get the source float
move.l YERK[(fltDisp)],d7
jsr 0(a3,d7.l) ; dispose of source float in d0
move.l d5,a2 ; get mstack
move.l (a2),a0 ; object base
adda.l a3,a0
move.l -4(a0),d7 ; get class
adda.w $12(a3,d7.l),a0 ; offset for ivar
move.l (a7)+,d1 ; get idx
mulu #10,d1 ; convert to offset
lea 4(a0,d1.l),a1 ; pt to element
move.l (a7)+,d0 ; get new float ptr
lea 2(a3,d0.l),a0 ; pt to source float
move.l (a0)+,(a1)+ ; deep copy of float data
move.l (a0)+,(a1)+
move.w (a0)+,(a1)+
;CODE
:CLASS fArray <Super Object 10 <Indexed
( index -- )
\ ( -- x ) return the float at index
:M AT: fltAt ;M
( index -- )
\ ( x -- ) store a new float at index
:M TO: fltTo ;M
:M +TO: ( x ind -- ) dup fltAt rot f+ swap fltTo ;M
\ ( x -- ) fill all elements wih x
:M FILL: limit 0
DO fdup I to: self LOOP fdrop ;M
:M PUT: ( x x x...) limit 0 DO limit i- 1- to: self LOOP ;M
:M GET: ( - x x x ..) limit limit: fltmem > classerr" 129
limit 0 DO i at: self LOOP ;M
\ Prints all elements
:M PRINT: limit: self 0 DO i dup 4 .r space at: self e. cr LOOP ;M
;CLASS
\ ( -- ) Initializes private floating point variables when present
:f LocalFloat
R 6 - dup c@ dup $ 0f and \ number of input parameters
rot 1+ c@ over >> \ get float mask and dump bits for input parms
rot 4 >> \ number of local variables
0 DO
dup 1 and \ get right most bit
IF over i + mPuts @mp \ if on then param+i is a float
0.0 swap execute
THEN
1 >> \ shift mask for next iteration
LOOP
2drop
;f